Allow guards for impersonatable struct type properties

collects/racket/private/promise.rkt

@@ -147,7 +147,7 @@
 ;; property value for the right forcer to use
 (define-values [prop:force promise-forcer]
   (let-values ([(prop pred? get) ; no need for the predicate
-                (make-struct-type-property 'forcer 'can-impersonate)])
+                (make-struct-type-property 'forcer #f null #t)])
     (values prop get)))
 
 ;; A promise value can hold

collects/scribblings/reference/struct.scrbl

@@ -304,7 +304,8 @@ A @deftech{structure type property} allows per-type information to be
                                     [guard (or/c procedure? #f 'can-impersonate) #f]
                                     [supers (listof (cons/c struct-type-property?
                                                             (any/c . -> . any/c)))
-                                            null])
+                                            null]
+                                    [can-impersonate? any/c #f])
          (values struct-type-property?
                  procedure?
                  procedure?)]{
@@ -355,9 +356,9 @@ returning a structure type descriptor.
 
 If @racket[guard] is @racket['can-impersonate], then the property's
 accessor can be redirected through
-@racket[impersonate-struct]. Otherwise, redirection of the property
+@racket[impersonate-struct]. This option is identical to supplying
-value through an @tech{impersonator} is disallowed, since redirection
+@racket[#t] as the @racket[can-impersonate?] argument and is provided
-is tantamount to mutation.
+for backwards compatibility.
 
 The optional @racket[supers] argument is a list of properties that are
 automatically associated with some structure type when the newly
@@ -367,6 +368,12 @@ supplied for the new property (after it is processed by
 @racket[guard]) and returns a value for the associated property (which
 is then sent to that property's guard, of any).
 
+The optional @racket[can-impersonate?] argument determines if the
+structure type property can be redirected through @racket[impersonate-struct].
+If the argument is @racket[#f], then redirection is not allowed.
+Otherwise, the property accessor may be redirected by a struct
+impersonator.
+
 @examples[
 #:eval struct-eval
 (define-values (prop:p p? p-ref) (make-struct-type-property 'p))

collects/tests/racket/chaperone.rktl

@@ -412,16 +412,20 @@
  (let ()
    (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
    (define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate))
+   (define-values (prop:red red? red-ref)
+     (make-struct-type-property 'red (lambda (v i) (symbol->string v)) null #t))
    (define-struct a ([x #:mutable] y))
    (define-struct (b a) ([z #:mutable]))
    (define-struct (c b) ([n #:mutable]) #:transparent)
    (define-struct p (u) #:property prop:green 'green)
+   (define-struct r (t) #:property prop:red 'red)
    (define-struct (q p) (v w))
    (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)
                                                       set-a-x! (lambda (a v) v)))
    (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)
                                                       set-a-x! (lambda (a v) v)))
    (test #t chaperone?/impersonator (chaperone-struct (make-p 1) green-ref (lambda (a v) v)))
+   (test #t chaperone?/impersonator (chaperone-struct (make-r 1) red-ref (lambda (a v) v)))
    (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)
                                                       set-a-x! (lambda (a v) v)
                                                       prop:blue 'blue))
@@ -553,6 +557,14 @@
              (test 'bad a-x a2)
              (test 'bad a-x a3)))))))
 
+;; test to see if the guard is actually called even when impersonated
+(let ()
+  (define-values (prop:red red? red-ref)
+    (make-struct-type-property 'red (lambda (v i) (symbol->string v)) null #t))
+  (define-struct a (b) #:property prop:red 'red)
+  (test "red" red-ref (impersonate-struct (make-a 1) red-ref (lambda (v f-v) f-v)))
+  (test 5 red-ref (impersonate-struct (make-a 1) red-ref (lambda (v f-v) 5))))
+
 ;; ----------------------------------------
 
 (as-chaperone-or-impersonator

collects/tests/racket/struct.rktl

@@ -7,7 +7,7 @@
 	     [(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)]
 	     [(insp1) (make-inspector)]
 	     [(insp2) (make-inspector)])
-  (arity-test make-struct-type-property 1 3)
+  (arity-test make-struct-type-property 1 4)
   (test 3 primitive-result-arity make-struct-type-property)
   (arity-test p? 1 1)
   (arity-test p-ref 1 2)
@@ -638,7 +638,7 @@
 ;; ------------------------------------------------------------
 ;; Property accessor errors
 
-(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop1 'can-impersonate '())])
+(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop1 #f '() #t)])
   (test 42 p-ref 5 42)
   (test 17 p-ref 5 (lambda () (* 1 17)))
   (err/rt-test (p-ref 5) exn:fail:contract?))

collects/typed-racket/base-env/base-env.rkt

@@ -2093,7 +2093,8 @@
 [make-struct-type-property
  (->opt Sym
        [(Un (one-of/c #f 'can-impersonate) (-> Univ (-lst Univ)))
-        (-lst (-pair -Struct-Type-Property (-> Univ Univ)))]
+        (-lst (-pair -Struct-Type-Property (-> Univ Univ)))
+        Univ]
        (-values (list -Struct-Type-Property (-> Univ B) (-> Univ Univ))))]
 
 [struct-type-property? (make-pred-ty -Struct-Type-Property)]

src/racket/src/schpriv.h

@@ -729,6 +729,7 @@ typedef struct Scheme_Inspector {
 
 typedef struct Scheme_Struct_Property {
   Scheme_Object so;
+  char can_impersonate; /* 1 if impersonatable property, 0 otherwise */
   Scheme_Object *name; /* a symbol */
   Scheme_Object *guard; /* NULL, a procedure, or 'can-impersonate */
   Scheme_Object *supers; /* implied properties: listof (cons <prop> <proc>) */

src/racket/src/struct.c

@@ -542,7 +542,7 @@ scheme_init_struct (Scheme_Env *env)
   scheme_add_global_constant("make-struct-type-property", 
 			    scheme_make_prim_w_arity2(make_struct_type_property,
 						      "make-struct-type-property",
-						      1, 3,
+						      1, 4,
 						      3, 3),
 			    env);
 
@@ -1112,6 +1112,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
   char *name;
   int len;
   const char *who;
+  char can_impersonate = 0;
 
   if (type == scheme_struct_property_type)
     who = "make-struct-type-property";
@@ -1124,6 +1125,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
     if (SCHEME_SYMBOLP(argv[1])
         && !SCHEME_SYM_WEIRDP(argv[1])
         && !strcmp("can-impersonate", SCHEME_SYM_VAL(argv[1]))) {
+      can_impersonate = 1;
     } else if (SCHEME_TRUEP(argv[1])
                && !scheme_check_proc_arity(NULL, 2, 1, argc, argv))
       scheme_wrong_contract(who, "(or/c (any/c any/c . -> . any) #f 'can-impersonate)", 1, argc, argv);
@@ -1153,6 +1155,9 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
                               "(listof (cons struct-type-property? (any/c . -> . any)))", 
                               2, argc, argv);
       }
+
+      if (argc > 3)
+        can_impersonate = SCHEME_TRUEP(argv[3]);
     }
   }
 
@@ -1162,6 +1167,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
   if ((argc > 1) && SCHEME_TRUEP(argv[1]))
     p->guard = argv[1];
   p->supers = supers;
+  p->can_impersonate = can_impersonate;
 
   a[0] = (Scheme_Object *)p;
 
@@ -5244,8 +5250,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
       pi = NULL;
 
       if (is_impersonator
-          && (!((Scheme_Struct_Property *)prop)->guard
+          && !((Scheme_Struct_Property *)prop)->can_impersonate)
-              || !SCHEME_SYMBOLP(((Scheme_Struct_Property *)prop)->guard)))
         scheme_contract_error(name,
                               "operation cannot be impersonated",
                               "operation kind", 0, kind,