add property support to chaperone-generic, etc.

pkgs/racket-doc/scribblings/reference/generic.scrbl

@@ -245,21 +245,34 @@ specified @racket[method-id]s with the corresponding @racket[method-ctc]s.
 
 }
 
-@defform[(impersonate-generics gen-id val-expr [method-id method-proc] ...)
+@defform[(impersonate-generics gen-id val-expr
-         #:contracts ([method-proc (any/c . -> . any/c)])]{
+           [method-id method-proc-expr] ...
+           maybe-properties)
+         #:grammar ([maybe-properties code:blank
+                                      (code:line #:properties props-expr)])
+         #:contracts ([method-proc-expr (any/c . -> . any/c)]
+                      [props-expr (list/c impersonator-property? any/c ... ...)])]{
 
 Creates an @tech{impersonator} of @racket[val-expr], which must be a structure
 that implements the @tech{generic interface} @racket[gen-id].  The impersonator
-applies the specified @racket[method-proc]s to the structure's implementation
+applies the results of the @racket[method-proc-expr]s to the structure's implementation
 of the corresponding @racket[method-id]s, and replaces the method
 implementation with the result.
 
-}
+A @racket[props-expr] can provide properties to attach to the
+impersonator. The result of @racket[props-expr] bust be an list with
+an even number of elements, where the first element of the list is an
+impersonator property, the second element is its value, and so on.
 
-@defform[(chaperone-generics gen-id val-expr [method-id method-proc] ...)
+@history[#:changed "6.1.1.8" @elem{Added @racket[#:properties].}]}
-         #:contracts ([method-proc (any/c . -> . any/c)])]{
 
-Creates a @tech{chaperone} of @racket[val-expr], which must be a structure
+
+@defform[(chaperone-generics gen-id val-expr
+           [method-id method-proc-expr] ...
+           maybe-properties)]{
+
+Like @racket[impersonate-generics], but
+creates a @tech{chaperone} of @racket[val-expr], which must be a structure
 that implements the @tech{generic interface} @racket[gen-id].  The chaperone
 applies the specified @racket[method-proc]s to the structure's implementation
 of the corresponding @racket[method-id]s, and replaces the method
@@ -267,13 +280,14 @@ implementation with the result, which must be a chaperone of the original.
 
 }
 
-@defform[(redirect-generics mode gen-id val-expr [method-id method-proc] ...)
+@defform[(redirect-generics mode gen-id val-expr
-         #:contracts ([method-proc (any/c . -> . any/c)])]{
+            [method-id method-proc-expr] ...
+            maybe-properties)]{
 
-Creates an @tech{impersonator} of @racket[val-expr], like
+Like @racket[impersonate-generics], but
-@racket[impersonate-generics], if @racket[mode] evaluates to @racket[#f].
+creates an @tech{impersonator} of @racket[val-expr]
-Creates a @tech{chaperone} of @racket[val-expr], like
+if @racket[mode] evaluates to @racket[#f], or creates
-@racket[chaperone-generics], otherwise.
+a @tech{chaperone} of @racket[val-expr] otherwise.
 
 }
 

pkgs/racket-test/tests/generic/impersonate.rkt

@@ -0,0 +1,62 @@
+#lang racket/base
+(require racket/generic
+         rackunit)
+
+(define-generics fish
+  [eat fish n]
+  [swim fish])
+
+(struct standard (size)
+        #:transparent
+        #:methods
+        gen:fish
+        [(define (eat self n) (standard (+ n (standard-size self))))
+         (define (swim self) (standard (max 0 (- (standard-size self) 1))))])
+
+(define-values (prop:color color? color-ref) (make-impersonator-property 'color))
+
+(define phil (standard 1))
+(check-equal? (standard 6) (eat (standard 1) 5))
+
+(define (chaperone-eat p)
+  (chaperone-procedure p
+                       (lambda (self amt)
+                         (values (lambda (r)
+                                   (chaperone-struct r struct:standard
+                                                     prop:color 'blue))
+                                 self
+                                 amt))))
+  
+(define not-phil
+  (impersonate-generics gen:fish 
+                        phil
+                        [eat chaperone-eat]))
+(check-true (impersonator-of? not-phil phil))
+(check-false (chaperone-of? not-phil phil))
+(check-false (color? not-phil))
+(check-true (color? (eat not-phil 2)))
+
+(define like-phil
+  (chaperone-generics gen:fish 
+                      phil
+                      [eat chaperone-eat]))
+(check-true (chaperone-of? like-phil phil))
+(check-false (color? like-phil))
+(check-true (color? (eat like-phil 2)))
+
+(define just-like-phil
+  (chaperone-generics gen:fish 
+                      phil
+                      #:properties (list prop:color 'red)))
+(check-true (color? just-like-phil))
+(check-false (color? (eat just-like-phil 2)))
+
+(define still-not-phil
+  (impersonate-generics gen:fish 
+                        phil
+                        [eat chaperone-eat]
+                        #:properties (list prop:color 'red)))
+(check-true (color? still-not-phil))
+(check-true (color? (eat still-not-phil 2)))
+
+

pkgs/racket-test/tests/generic/tests.rkt

@@ -20,5 +20,6 @@
          "top-level.rkt"
          "pr13737.rkt"
          "marked.rkt"
-         "methods.rkt")
+         "methods.rkt"
+         "impersonate.rkt")
 

racket/collects/racket/generic.rkt

@@ -169,7 +169,7 @@
 
 (define-syntax (redirect-generics/derived stx)
   (syntax-case stx ()
-    [(_ orig mode gen-name val-expr [method-name proc-expr] ...)
+    [(_ orig mode gen-name val-expr [method-name proc-expr] ... props-expr)
      (parameterize ([current-syntax-context #'orig])
        (define gen-id #'gen-name)
        (unless (identifier? gen-id)
@@ -192,26 +192,42 @@
                                    (case i
                                      [(method-index) (proc-expr x)]
                                      ...
-                                     [else x]))))]))
+                                     [else x]))
+                                 props-expr))]))
 
 (define-syntax (redirect-generics stx)
   (syntax-case stx ()
     [(_ mode gen-name val-expr [id expr] ...)
-     #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ...)]))
+     #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... null)]
+    [(_ mode gen-name val-expr [id expr] ... #:properties props-expr)
+     #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... props-expr)]))
 
 (define-syntax (chaperone-generics stx)
   (syntax-case stx ()
     [(_ gen-name val-expr [id expr] ...)
-     #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ...)]))
+     #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... null)]
+    [(_ gen-name val-expr [id expr] ... #:properties props-expr)
+     #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... props-expr)]))
 
 (define-syntax (impersonate-generics stx)
   (syntax-case stx ()
     [(_ gen-name val-expr [id expr] ...)
-     #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ...)]))
+     #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... null)]
+    [(_ gen-name val-expr [id expr] ... #:properties props-expr)
+     #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... props-expr)]))
 
-(define (redirect-generics-proc name chaperoning? pred ref x proc)
+(define (redirect-generics-proc name chaperoning? pred ref x proc props)
   (unless (pred x)
-    (raise-argument-error name (format "a structure implementing ~a" name) x))
+    (raise-argument-error name (format "~a?" name) x))
+  (unless (and (list? props)
+               (let loop ([props props])
+                 (cond
+                  [(null? props) #t]
+                  [(null? (cdr props)) #f]
+                  [(impersonator-property? (car props))
+                   (loop (cddr props))]
+                  [else #f])))
+    (raise-argument-error name "(list/c impersonator-property? any/c ... ...)" props))
   (define-values (redirect-struct redirect-vector)
     (if chaperoning?
         (values chaperone-struct chaperone-vector)
@@ -220,7 +236,7 @@
     (proc i method))
   (define (struct-proc x vec)
     (redirect-vector vec vec-proc vec-proc))
-  (redirect-struct x ref struct-proc))
+  (apply redirect-struct x ref struct-proc props))
 
 (define-syntax-rule (define-generics-contract ctc-name gen-name)
   (define-syntax (ctc-name stx)