Add prop:match-expander' and prop:legacy-match-expander'.

collects/racket/match/match.rkt

@@ -6,14 +6,17 @@
          (only-in "match-expander.rkt"
                   define-match-expander)
          "define-forms.rkt"
-         "struct.rkt"
+         "struct.rkt"         
          (for-syntax "parse.rkt"
-                     (only-in "patterns.rkt" match-...-nesting)))
+                     (only-in "patterns.rkt" 
+                              match-...-nesting
+                              prop:match-expander prop:legacy-match-expander)))
 
-(provide (for-syntax match-...-nesting)
+(provide (for-syntax match-...-nesting
+                     prop:match-expander prop:legacy-match-expander)
          match-equality-test
          define-match-expander
-         struct* ==
+         struct* ==          
          exn:misc:match?)
 
 (define-forms parse

collects/racket/match/parse-helper.rkt

@@ -138,13 +138,16 @@
                                   error-msg)
   (let* ([expander* (syntax-local-value expander)]
          [transformer (accessor expander*)]
+         ;; this transformer might have been defined w/ `syntax-id-rules'
          [transformer (if (set!-transformer? transformer)
                           (set!-transformer-procedure transformer)
                           transformer)])
     (unless transformer (raise-syntax-error #f error-msg expander*))
     (let* ([introducer (make-syntax-introducer)]
            [mstx (introducer (syntax-local-introduce stx))]
-           [mresult (transformer mstx)]
+           [mresult (if (procedure-arity-includes? transformer 2) 
+                        (transformer expander* mstx)
+                        (transformer mstx))]
            [result (syntax-local-introduce (introducer mresult))])
       ;(emit-local-step stx result #:id expander)
       (parse result))))

collects/racket/match/parse-legacy.rkt

@@ -18,10 +18,10 @@
                 (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
     [(expander args ...)
      (and (identifier? #'expander)
-          (match-expander?
+          (legacy-match-expander?
-           (syntax-local-value #'expander (lambda () #f))))
+           (syntax-local-value #'expander (λ () #f))))
      (match-expander-transform
-      parse #'expander disarmed-stx match-expander-legacy-xform
+      parse #'expander disarmed-stx legacy-match-expander-proc
       "This expander only works with the standard match syntax")]
     [(and p ...)
      (make-And (map parse (syntax->list #'(p ...))))]

collects/racket/match/parse.rkt

@@ -32,7 +32,7 @@
           (match-expander? (syntax-local-value #'expander
                                                (lambda () #f))))
      (match-expander-transform
-      rearm+parse #'expander disarmed-stx match-expander-match-xform
+      rearm+parse #'expander disarmed-stx match-expander-proc
       "This expander only works with the legacy match syntax")]
     [(var v)
      (identifier? #'v)

collects/racket/match/patterns.rkt

@@ -1,8 +1,8 @@
-#lang scheme/base
+#lang racket/base
 
 (require syntax/boundmap
-         scheme/contract
+         racket/contract
-         (for-syntax scheme/base))
+         (for-syntax racket/base))
 
 (provide (except-out (all-defined-out)
                      struct-key-ht
@@ -208,20 +208,45 @@
                                [vars-seen (listof (cons/c identifier?
                                                           identifier?))])))
 
-(define-struct match-expander (match-xform legacy-xform macro-xform)
-#|  #:property prop:procedure (lambda (me stx)
-                              (define xf (match-expander-macro-xform me))
-                              (define xf* (if (set!-transformer? xf)
-                                              (set!-transformer-procedure xf)
-                                              xf))
-                              (xf* stx))|#
-  #:property prop:set!-transformer (lambda (me stx)
-                                     (define xf (match-expander-macro-xform me))
-                                     (if (set!-transformer? xf)
-                                         ((set!-transformer-procedure xf) stx)
-                                         (syntax-case stx (set!)
-                                           [(set! . _)
-                                            (raise-syntax-error #f "cannot mutate syntax identifier" stx)]
-                                           [_ (xf stx)]))))
 
-(provide (struct-out match-expander))
+(struct acc-prop (n acc))
+(define (make-struct-type-property/accessor name [guard #f] [supers null])
+  (define-values (p pred? acc)
+    (make-struct-type-property name
+     (λ (pval sinfo)
+	(cond [(exact-nonnegative-integer? pval)
+	       (acc-prop pval (cadddr sinfo))]
+	      [else (if (procedure? guard) 
+			(guard pval sinfo)
+			pval)]))
+     supers))
+  (values p pred? (lambda (v)
+		    (define v* (acc v))
+		    (if (acc-prop? v*)
+			((acc-prop-acc v*) v (acc-prop-n v*))
+			v*))))
+
+(define-values (prop:match-expander match-expander? match-expander-proc) 
+  (make-struct-type-property/accessor 'prop:match-expander))
+
+(define-values (prop:legacy-match-expander legacy-match-expander? legacy-match-expander-proc)
+  (make-struct-type-property/accessor 'prop:legacy-match-expander ))
+
+(define make-match-expander
+  (let ()
+    (define-struct match-expander (match-xform legacy-xform macro-xform)
+      #:property prop:set!-transformer (lambda (me stx)
+                                         (define xf (match-expander-macro-xform me))
+                                         (if (set!-transformer? xf)
+                                             ((set!-transformer-procedure xf) stx)
+                                             (syntax-case stx (set!)
+                                               [(set! . _)
+                                                (raise-syntax-error #f "cannot mutate syntax identifier" stx)]
+                                               [_ (xf stx)])))
+      #:property prop:match-expander (struct-field-index match-xform)
+      #:property prop:legacy-match-expander (struct-field-index legacy-xform))
+    (values make-match-expander)))
+
+(provide match-expander? legacy-match-expander?
+         match-expander-proc legacy-match-expander-proc
+         prop:match-expander prop:legacy-match-expander)

collects/scribblings/reference/match.scrbl

@@ -525,6 +525,35 @@ For example, to extend the pattern matcher and destructure syntax lists,
 
 }
 
+@defthing[prop:match-expander struct-type-property?]{
+
+A @tech{structure type property} to identify structure types that act
+as @tech{match expanders} like the ones created by
+@racket[define-match-expander].
+
+The property value must be an exact non-negative integer or a
+procedure of one or two arguments.  In the former case, the integer
+designates a field within the structure that should contain a
+procedure; the integer must be between @racket[0] (inclusive) and the
+number of non-automatic fields in the structure type (exclusive, not
+counting supertype fields), and the designated field must also be
+specified as immutable.
+
+If the property value is a procedure of one argument, then the
+procedure serves as the transformer for match expansion. If the property value is a procedure of two
+arguments, then the first argument is the structure whose type has
+@racket[prop:match-expander] property, and the second argument is a
+syntax object as for a @tech{match expander}..
+
+If the property value is a @tech{assignment transformer}, then the wrapped
+procedure is extracted with
+@racket[set!-transformer-procedure] before it is called.
+}
+
+@defthing[prop:legacy-match-expander struct-type-property?]{
+Like @racket[prop:match-expander], but for the legacy match syntax.
+}
+
 
 @defparam[match-equality-test comp-proc (any/c any/c . -> . any)]{