[plt-scheme] Using the struct type identifier as a macro [PATCH]

On Mon, 17 Nov 2008, Dimitris Vyzovitis wrote:

> On Sun, 16 Nov 2008, Dave Herman wrote:
>
>> Does your patch also bind the struct name as an identifier macro so it can 
>> be used in a higher-order fashion? E.g.:
>
> Not currently, but this is straightforward; I can add it.

Updated patch attached (svn12467, aka 4.1.3.1, but the affected files are 
the same in 4.1.2 so it should apply there as well)

-- vyzo

PS: damn, make install takes ages...
-------------- next part --------------
Index: collects/scheme/match/parse.ss
===================================================================
--- collects/scheme/match/parse.ss	(revision 12467)
+++ collects/scheme/match/parse.ss	(working copy)
@@ -152,6 +152,10 @@
     [(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
     [(struct s pats)
      (parse-struct stx cert parse #'s #'pats)]
+    [(type pat ...)
+     (and (identifier? #'type) 
+          (struct-info? (syntax-local-value (cert #'type) (lambda () #f))))
+     (parse-struct stx cert parse #'type #'(pat ...))]
     [(? p q1 qs ...)
      (make-And (cons (make-Pred (cert #'p))
                      (map parse (syntax->list #'(q1 qs ...)))))]
Index: collects/scheme/private/define-struct.ss
===================================================================
--- collects/scheme/private/define-struct.ss	(revision 12467)
+++ collects/scheme/private/define-struct.ss	(working copy)
@@ -26,10 +26,20 @@
                       0 0 #f
                       null (current-inspector)
                       (lambda (v stx)
-                        (raise-syntax-error
-                         #f
-                         "identifier for static struct-type information cannot be used as an expression"
-                         stx))
+                        (let-values (((kons) (cadr (extract-struct-info v))))
+                          (if kons
+                            (if (list? (syntax-e stx))
+                              (datum->syntax stx (cons kons (cdr (syntax-e stx))) stx)
+                              (if (symbol? (syntax-e stx))
+                                kons 
+                                (raise-syntax-error
+                                    #f
+                                  "illegal use of struct-type identifier"
+                                  stx)))
+                            (raise-syntax-error
+                                #f
+                              "identifier for static struct-type information cannot be used as an expression"
+                              stx))))
                       null
                       (lambda (proc info)
                         (if (and (procedure? proc)
Index: collects/scheme/private/struct-info.ss
===================================================================
--- collects/scheme/private/struct-info.ss	(revision 12467)
+++ collects/scheme/private/struct-info.ss	(working copy)
@@ -16,10 +16,20 @@
                       1 0 #f
                       null (current-inspector)
                       (lambda (v stx)
-                        (raise-syntax-error
-                         #f
-                         "identifier for static struct-type information cannot be used as an expression"
-                         stx))
+                        (let-values (((kons) (cadr (extract-struct-info v))))
+                          (if kons
+                            (if (list? (syntax-e stx))
+                              (datum->syntax stx (cons kons (cdr (syntax-e stx))) stx)
+                              (if (symbol? (syntax-e stx))
+                                kons
+                                (raise-syntax-error
+                                    #f
+                                  "illegal use of struct-type identifier"
+                                  stx)))
+                            (raise-syntax-error
+                                #f
+                              "identifier for static struct-type information cannot be used as an expression"
+                              stx))))
                       null
                       (lambda (proc info)
                         (if (and (procedure? proc)