Implementation, documentation and tests for adding a failure-result to property accessor procedures.

collects/scribblings/reference/struct.scrbl

@@ -309,11 +309,17 @@ Creates a new structure type property and returns three values:
        descriptor or instance of a structure type that has a value for
        the property, @racket[#f] otherwise;}
 
- @item{an @deftech{property accessor} procedure, which returns the
+ @item{a @deftech{property accessor} procedure, which returns the
        value associated with the structure type given its descriptor or
        one of its instances; if the structure type does not have a
        value for the property, or if any other kind of value is
-       provided, the @exnraise[exn:fail:contract].}
+       provided, the @exnraise[exn:fail:contract] unless a second
+       argument, @racket[failure-result], is supplied to the
+       procedure. In that case, if @racket[failure-result] is a
+       procedure, it is called (through a tail call) with no arguments
+       to produce the result of the property accessor procedure;
+       otherwise, @racket[failure-result] is itself returned as the
+       result.}
 
 ]
 

collects/tests/racket/struct.rktl

@@ -635,6 +635,14 @@
 		two132-a x132 6
 		one32-y x132 4))))
 
+;; ------------------------------------------------------------
+;; Property accessor errors
+
+(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop1 'can-impersonate '())])
+  (test 42 p-ref 5 42)
+  (test 17 p-ref 5 (lambda () (* 1 17)))
+  (err/rt-test (p-ref 5) exn:fail:contract?))
+
 ;; ------------------------------------------------------------
 ;; Property type supers
 

src/racket/src/struct.c

@@ -1005,12 +1005,20 @@ static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Objec
   else
     v = do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], v);
 
-  if (!v)
+  if (v)
+    return v;
+  else if (argc == 1) {
     scheme_wrong_type(((Scheme_Primitive_Proc *)prim)->name,
 		      "struct or struct-type with property",
-                      0, 1, args);
-  
-  return v;
+		      0, 1, args);
+    return NULL;
+  } else {
+    v = args[1];
+    if (SCHEME_PROCP(v))
+      return _scheme_tail_apply(v, 0, NULL);
+    else
+      return v;
+  }
 }
 
 static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *argv[],
@@ -1090,7 +1098,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
   memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
   memcpy(name + len, "-accessor", 10);
 
-  v = scheme_make_folding_prim_closure(prop_accessor, 1, a, name, 1, 1, 0);
+  v = scheme_make_folding_prim_closure(prop_accessor, 1, a, name, 1, 2, 0);
   ((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER;
   
   *accessout = v;