struct: add #:properties prop-alist-expr option

Add a #:properties option to struct that takes an association
list (same type as make-struct-type).

This makes struct a better target for macros, since the
calculation of properties can be separated from the rest of the
struct declaration. Multiple property values can be calculated in
a single expression position, making it easier for property
values to share intermediate calculations and syntax bindings.

Author: rmculpepper

pkgs/racket-doc/scribblings/reference/define-struct.scrbl

@@ -23,6 +23,7 @@
                               (code:line #:auto-value auto-expr)
                               (code:line #:guard guard-expr)
                               (code:line #:property prop-expr val-expr)
+                              (code:line #:properties prop-list-expr)
                               (code:line #:transparent)
                               (code:line #:prefab)
                               (code:line #:sealed)
@@ -133,9 +134,10 @@ procedure, respectively. See @racket[make-struct-type] for more
 information on these attributes of a structure type.  The
 @racket[#:property] option, which can be supplied
 multiple times, attaches a property value to the structure type; see
-@secref["structprops"] for more information on properties. The
-@racket[#:transparent] option is a shorthand for @racket[#:inspector
-#f].
+@secref["structprops"] for more information on properties.
+The @racket[#:properties] option, which can be supplied multiple times,
+accepts multiple properties and their values as an association list.
+The @racket[#:transparent] option is a shorthand for @racket[#:inspector #f].
 
 @examples[#:eval posn-eval
   (struct point (x y) #:inspector #f)
@@ -307,7 +309,8 @@ cp
 For serialization, see @racket[define-serializable-struct].
 
 @history[#:changed "6.9.0.4" @elem{Added @racket[#:authentic].}
-         #:changed "8.0.0.7" @elem{Added @racket[#:sealed].}]}
+         #:changed "8.0.0.7" @elem{Added @racket[#:sealed].}
+         #:changed "8.17.0.4" @elem{Added @racket[#:properties].}]}
 
 
 @defform[(struct-field-index field-id)]{

pkgs/racket-test-core/tests/racket/struct.rktl

@@ -1240,6 +1240,31 @@
 
 ;; ----------------------------------------
 
+(let ()
+  (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
+  (define-values (prop:b b? b-ref) (make-struct-type-property 'b))
+  (define-values (prop:c c? c-ref) (make-struct-type-property 'c))
+  (struct s (x y)
+    #:properties (list (cons prop:a "abc") (cons prop:b "xyz"))
+    #:property prop:procedure (lambda (self arg) arg)
+    #:properties (list (cons prop:c 'here)))
+
+  (test "abc" a-ref (s 1 2))
+  (test "xyz" b-ref (s 1 2))
+  (test 'here c-ref (s 1 2))
+  (test 123 (s 1 2) 123)
+
+  ;; Allow #:properties with #:prefab, dynamic error if non-empty
+  (struct ps1 (x y) #:prefab #:properties null)
+  (struct ps2 (x [y #:mutable]) #:properties null #:prefab)
+  (err/rt-test (let ()
+                 (struct pbad (x y)
+                   #:prefab
+                   #:properties (list (cons prop:procedure void)))
+                 (void))))
+
+;; ----------------------------------------
+
 (require (for-syntax racket/struct-info))
 
 (let ()

racket/collects/racket/private/define-struct.rkt

@@ -143,6 +143,17 @@
       (raise-argument-error name "symbol?" what))
     what)
 
+  (define (check-property-alist name what)
+    (unless (and (list? what)
+                 (andmap (lambda (elem)
+                           (and (pair? elem)
+                                (struct-type-property? (car elem))))
+                         what))
+      (raise-argument-error name
+                            "(listof (cons struct-type-property? any/c))"
+                            what))
+    what)
+
   (define-syntax (define-struct* stx)
     (syntax-case stx ()
       [(_ . rest)
@@ -260,6 +271,7 @@
                            (#:inspector . #f)
                            (#:auto-value . #f)
                            (#:props . ())
+                           (#:proplists . ())
                            (#:mutable . #f)
                            (#:guard . #f)
                            (#:constructor-name . #f)
@@ -312,6 +324,17 @@
                                (cons (cons (cadr p) (caddr p))
                                      (lookup config '#:props)))
                 nongen?)]
+         [(eq? '#:properties (syntax-e (car p)))
+          (check-exprs 1 p #f)
+          (when nongen?
+            ;; no error, since `#:properties null` should be allowed for prefab
+            (void))
+          (loop (cddr p)
+                (extend-config config
+                               '#:proplists
+                               (cons #`(check-property-alist '#,fm #,(cadr p))
+                                     (lookup config '#:proplists)))
+                nongen?)]
          [(eq? '#:methods (syntax-e (car p)))
           ;; #:methods gen:foo [(define (meth1 x ...) e ...) ...]
           (check-exprs 2 p "argument")
@@ -494,7 +517,7 @@
                          (car field-stxes))]
                        [else
                         (loop (cdr fields) (cdr field-stxes) #f)]))])
-               (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? 
+               (let*-values ([(inspector super-expr props proplists auto-val guard ctor-name ctor-only?
                                          reflect-name-expr mutable?
                                          omit-define-values? omit-define-syntaxes?
                                          info-name name-only?)
@@ -512,6 +535,7 @@
                                                 (cons (cons #'prop:sealed #'#t)
                                                       l)
                                                 l)))
+                                        (lookup config '#:proplists)
                                         (lookup config '#:auto-value)
                                         (lookup config '#:guard)
                                         (lookup config '#:constructor-name)
@@ -672,11 +696,18 @@
                                                                   #,(- (length fields) auto-count)
                                                                   #,auto-count
                                                                   #,auto-val
-                                                                  #,(if (null? props)
-                                                                        #'null
-                                                                        #`(list #,@(map (lambda (p)
-                                                                                          #`(cons #,(car p) #,(cdr p)))
-                                                                                        props)))
+                                                                  #,(cond
+                                                                     [(and (null? props) (null? proplists))
+                                                                      #'null]
+                                                                     [(null? proplists)
+                                                                      #`(list #,@(map (lambda (p)
+                                                                                        #`(cons #,(car p) #,(cdr p)))
+                                                                                      props))]
+                                                                     [else
+                                                                      #`(list* #,@(map (lambda (p)
+                                                                                         #`(cons #,(car p) #,(cdr p)))
+                                                                                       props)
+                                                                               (append #,@proplists))])
                                                                   #,(or inspector
                                                                         #`(current-inspector))
                                                                   #f