add name argument to make-parameter

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

@@ -31,18 +31,26 @@ value originally associated with a parameter through
 reachable, even if the parameter is mutated.
 
 @defproc[(make-parameter [v any/c]
-                         [guard (or/c (any/c . -> . any) #f) #f]) 
+                         [guard (or/c (any/c . -> . any) #f) #f]
+                         [name symbol? 'parameter-procedure])
          parameter?]{
 
 Returns a new parameter procedure. The value of the parameter is
-initialized to @racket[v] in all threads.  If @racket[guard] is
+initialized to @racket[v] in all threads.
-supplied, it is used as the parameter's guard procedure.  A guard
+
+If @racket[guard] is not @racket[#f],
+it is used as the parameter's guard procedure.  A guard
 procedure takes one argument. Whenever the parameter procedure is
 applied to an argument, the argument is passed on to the guard
 procedure. The result returned by the guard procedure is used as the
 new parameter value.  A guard procedure can raise an exception to
 reject a change to the parameter's value. The @racket[guard] is not
-applied to the initial @racket[v].}
+applied to the initial @racket[v].
+
+The @racket[name] argument is used as the parameter procedure's name
+as reported by @racket[object-name].
+
+@history[#:changed "7.4.0.6" @elem{Added the @racket[name] argument.}]}
 
 @defform[(parameterize ([parameter-expr value-expr] ...)
            body ...+)

pkgs/racket-test-core/tests/racket/param.rktl

@@ -166,9 +166,12 @@
       (test v cd)
       (test v current-directory))))
 
-(arity-test make-parameter 1 2)
+(test 'this-one object-name (make-parameter 7 #f 'this-one))
+
+(arity-test make-parameter 1 3)
 (err/rt-test (make-parameter 0 zero-arg-proc))
 (err/rt-test (make-parameter 0 two-arg-proc))
+(err/rt-test (make-parameter 0 #f 7))
 
 (define-struct bad-test (value exn?))
 

racket/src/cs/rumble/parameter.ss

@@ -24,7 +24,7 @@
                  [v (if guard
                         (|#%app| guard v)
                         v)])
-            (loop (intmap-set ht p (make-thread-cell v #t))
+            (loop (intmap-set ht (parameter-key p) (make-thread-cell v #t))
                   (cddr args)))]))]
      [(parameter? (car args))
       (raise-arguments-error 'extend-parameterization
@@ -53,7 +53,8 @@
               #f))
 
 (define-record-type parameter-data
-  (fields guard))
+  (fields guard
+          (mutable name))) ; not actually mutable, but ensures fresh allocations
 
 (define-record-type derived-parameter-data
   (parent parameter-data)
@@ -69,6 +70,9 @@
 (define (parameter-guard p)
   (parameter-data-guard (wrapper-procedure-data p)))
 
+(define (parameter-key p)
+  (wrapper-procedure-data p))
+
 (define (derived-parameter? v)
   (and (wrapper-procedure? v)
        (derived-parameter-data? (wrapper-procedure-data v))))
@@ -78,28 +82,27 @@
 
 (define/who make-parameter
   (case-lambda
-    [(v) (make-parameter v #f)]
+    [(v) (make-parameter v #f 'parameter-procedure)]
-    [(v guard)
+    [(v guard) (make-parameter v guard 'parameter-procedure)]
+    [(v guard name)
      (check who (procedure-arity-includes/c 1) :or-false guard)
-     (let ([default-c (make-thread-cell v #t)])
+     (check who symbol? name)
-       (letrec ([self
+     (let ([default-c (make-thread-cell v #t)]
-                 (make-wrapper-procedure
+           [data (make-parameter-data guard name)])
-                  (|#%name|
+       (make-arity-wrapper-procedure
-                   parameter-procedure
+        (case-lambda
-                   (case-lambda
+         [()
-                    [()
+          (let ([c (or (parameter-cell data)
-                     (let ([c (or (parameter-cell self)
+                       default-c)])
-                                  default-c)])
+            (thread-cell-ref c))]
-                       (thread-cell-ref c))]
+         [(v)
-                    [(v)
+          (let ([c (or (parameter-cell data)
-                     (let ([c (or (parameter-cell self)
+                       default-c)])
-                                  default-c)])
+            (thread-cell-set! c (if guard
-                       (thread-cell-set! c (if guard
+                                    (guard v)
-                                               (guard v)
+                                    v)))])
-                                               v)))]))
+        3
-                   3
+        data))]))
-                   (make-parameter-data guard))])
-         self))]))
 
 (define/who (make-derived-parameter p guard wrap)
   (check who authentic-parameter?
@@ -107,16 +110,16 @@
          p)
   (check who (procedure-arity-includes/c 1) guard)
   (check who (procedure-arity-includes/c 1) wrap)
-  (make-wrapper-procedure (let ([self p])
+  (make-arity-wrapper-procedure
-                            (|#%name|
+   (case-lambda
-                             parameter-procedure
+    [(v) (p (guard v))]
-                             (case-lambda
+    [() (wrap (p))])
-                              [(v) (self (guard v))]
+   3
-                              [() (wrap (self))])))
+   (make-derived-parameter-data
-                          3
+    guard
-                          (make-derived-parameter-data
+    (parameter-data-name
-                           guard
+     (wrapper-procedure-data p))
-                           p)))
+    p)))
 
 (define/who (parameter-procedure=? a b)
   (check who parameter? a)
@@ -133,10 +136,12 @@
   (make-parameter root-inspector
                   (lambda (v)
                     (check who inspector? v)
-                    v)))
+                    v)
+                  'current-inspector))
 
 (define/who current-code-inspector
   (make-parameter root-inspector
                   (lambda (v)
                     (check who inspector? v)
-                    v)))
+                    v)
+                  'current-code-inspector))

racket/src/cs/rumble/procedure.ss

@@ -502,7 +502,7 @@
      [(#%box? name) (#%unbox name)]
      [(#%vector? name) (or (#%vector-ref name 0)
                            (object-name (#%vector-ref name 1)))]
-     [(parameter-data? name) 'parameter-procedure]
+     [(parameter-data? name) (parameter-data-name name)]
      [else name])))
 
 ;; ----------------------------------------

racket/src/racket/src/thread.c

@@ -570,7 +570,7 @@ void scheme_init_thread(Scheme_Startup_Env *env)
   ADD_PARAMETER("current-thread-group", current_thread_set, MZCONFIG_THREAD_SET, env);
 
   ADD_PRIM_W_ARITY("parameter?"            , parameter_p           , 1, 1, env);
-  ADD_PRIM_W_ARITY("make-parameter"        , make_parameter        , 1, 2, env);
+  ADD_PRIM_W_ARITY("make-parameter"        , make_parameter        , 1, 3, env);
   ADD_PRIM_W_ARITY("make-derived-parameter", make_derived_parameter, 3, 3, env);
   ADD_PRIM_W_ARITY("parameter-procedure=?" , parameter_procedure_eq, 2, 2, env);
   ADD_PRIM_W_ARITY("parameterization?"     , parameterization_p    , 1, 1, env);
@@ -7842,11 +7842,18 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv)
   Scheme_Object *p, *cell, *a[1];
   ParamData *data;
   void *k;
+  const char *name;
 
   k = scheme_make_pair(scheme_true, scheme_false); /* generates a key */
 
   if (argc > 1)
-    scheme_check_proc_arity("make-parameter", 1, 1, argc, argv);
+    scheme_check_proc_arity2("make-parameter", 1, 1, argc, argv, 1);
+  if (argc > 2) {
+    if (!SCHEME_SYMBOLP(argv[2]))
+      scheme_wrong_contract("make-parameter", "parameter?", 2, argc, argv);
+    name = scheme_symbol_val(argv[2]);
+  } else
+    name = "parameter-procedure";
 
   data = MALLOC_ONE_RT(ParamData);
 #ifdef MZTAG_REQUIRED
@@ -7855,11 +7862,11 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv)
   data->key = (Scheme_Object *)k;
   cell = scheme_make_thread_cell(argv[0], 1);
   data->defcell = cell;
-  data->guard = ((argc > 1) ? argv[1] : NULL);
+  data->guard = (((argc > 1) && SCHEME_TRUEP(argv[1])) ? argv[1] : NULL);
 
   a[0] = (Scheme_Object *)data;
   p = scheme_make_prim_closure_w_arity(do_param_fast, 1, a, 
-                                       "parameter-procedure", 0, 1);
+                                       name, 0, 1);
   ((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER;
 
   return p;

racket/src/schemify/parameter-result.rkt

@@ -6,18 +6,14 @@
 
 (define (parameter-result? v prim-knowns knowns mutated)
   (and (wrap-pair? v)
-       (let ([v (wrap-cdr v)])
-         (and (wrap-pair? v)
-              (let ([v (wrap-cdr v)])
-                (or (wrap-null? v)
-                    (and (wrap-pair? v)
-                         (wrap-null? (wrap-cdr v)))))))
        (let ([u-rator (unwrap (wrap-car v))])
          (or (eq? u-rator 'make-parameter)
+             (eq? u-rator 'derived-parameter)
              (eq? u-rator 'make-pthread-parameter)
              (and (symbol? u-rator)
                   (let ([k (hash-ref knowns u-rator #f)])
                     (and (known-copy? k)
                          (let ([id (known-copy-id k)])
                            (or (eq? 'make-parameter id)
+                               (eq? 'make-derived-parameter id)
                                (eq? 'make-pthread-parameter id))))))))))