From 71eef1bbd840df284b822f2c1eb1f2e939eebbe7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 20 Nov 2009 20:45:45 +0000 Subject: [PATCH] Allow for changing the name on flat contracts via flat-named-contract. svn: r16928 --- collects/scheme/contract/private/guts.ss | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index e6e1980217..96e85aac05 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -361,10 +361,16 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (flat-named-contract name predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate)) - (make-predicate-contract name predicate)) + (cond + [(and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (make-predicate-contract name predicate)] + [(flat-contract? predicate) + (make-predicate-contract name (flat-contract-predicate predicate))] + [else + (error 'flat-named-contract + "expected a flat contract or procedure of arity 1 as second argument, got ~e" + predicate)])) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) (define (build-compound-type-name . fs)