diff --git a/collects/scheme/contract/private/prop.ss b/collects/scheme/contract/private/prop.ss index f011a52591..3605bd958c 100644 --- a/collects/scheme/contract/private/prop.ss +++ b/collects/scheme/contract/private/prop.ss @@ -27,7 +27,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-struct contract-property [ name first-order projection stronger ] +(define-struct contract-property [ name first-order projection stronger generator ] #:omit-define-syntaxes) (define (contract-property-guard prop info) @@ -112,7 +112,8 @@ #:name [get-name #f] #:first-order [get-first-order #f] #:projection [get-projection #f] - #:stronger [stronger #f]) + #:stronger [stronger #f] + #:generator [generator #f]) (let* ([get-name (or get-name (lambda (c) default-name))] [get-first-order (or get-first-order get-any?)] @@ -121,7 +122,7 @@ get-name get-first-order))] [stronger (or stronger weakest)]) - (mk get-name get-first-order get-projection stronger))) + (mk get-name get-first-order get-projection stronger generator))) (define build-contract-property (build-property make-contract-property 'anonymous-contract)) @@ -156,7 +157,8 @@ (lambda (c) (make-contract-name c)) (lambda (c) (make-contract-first-order c)) (lambda (c) (make-contract-projection c)) - (lambda (a b) ((make-contract-stronger a) a b)))) + (lambda (a b) ((make-contract-stronger a) a b)) + #f)) (define-struct make-flat-contract [ name first-order projection stronger ] #:omit-define-syntaxes @@ -166,7 +168,8 @@ (lambda (c) (make-flat-contract-name c)) (lambda (c) (make-flat-contract-first-order c)) (lambda (c) (make-flat-contract-projection c)) - (lambda (a b) ((make-flat-contract-stronger a) a b))))) + (lambda (a b) ((make-flat-contract-stronger a) a b)) + #f))) (define ((build-contract mk default-name) #:name [name #f] diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 9e2a2ba2ac..01ef221321 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1246,7 +1246,15 @@ constructed by @scheme[build-flat-contract-property]. (if ((get-first-order c) x) x (raise-blame-error - b x "expected <~a>, given: ~e" (get-name c) x)))))]) + b x "expected <~a>, given: ~e" (get-name c) x)))))] + [#:stronger + stronger + (or/c (-> contract? contract? boolean?) #f) + #f] + [#:generator + generator + (or/c (-> number? (listof (list any/c contract?)) any/c) #f) + #f]) flat-contract-property?] @defproc[(build-contract-property [#:name @@ -1266,7 +1274,15 @@ constructed by @scheme[build-flat-contract-property]. (if ((get-first-order c) x) x (raise-blame-error - b x "expected <~a>, given: ~e" (get-name c) x)))))]) + b x "expected <~a>, given: ~e" (get-name c) x)))))] + [#:stronger + stronger + (or/c (-> contract? contract? boolean?) #f) + #f] + [#:generator + generator + (or/c (-> number? (listof (list any/c contract?)) any/c) #f) + #f]) contract-property?] )]{ @@ -1274,11 +1290,16 @@ These functions build the arguments for @scheme[prop:contract] and @scheme[prop:flat-contract], respectively. A @deftech{contract property} specifies the behavior of a structure when used as -a contract. It is specified in terms of three accessors: @scheme[get-name], -which produces a description to @scheme[display] during a contract violation; +a contract. It is specified in terms of five accessors: @scheme[get-name], +which produces a description to @scheme[write] as part of a contract violation; @scheme[get-first-order], which produces a first order predicate to be used by -@scheme[contract-first-order-passes?]; and @scheme[get-projection], which -produces a blame-tracking projection defining the behavior of the contract. +@scheme[contract-first-order-passes?]; @scheme[get-projection], which +produces a blame-tracking projection defining the behavior of the contract; +@scheme[stronger], which is a predicate that determines if one contract this contract +(passed in the first argument) is stronger than some other contract (passed in the second argument); +and @scheme[generator], which makes a random value that matches the contract, +given a size bound and an environment from which to draw interesting values. + These accessors are passed as (optional) keyword arguments to @scheme[build-contract-property], and are applied to instances of the appropriate structure type by the contract system. Their results are used